home *** CD-ROM | disk | FTP | other *** search
/ BMUG PD-ROM 1995 Fall / PD-ROM F95.toast / Programming / Programming Languages / Pixie Scheme ƒ / Pixie Scheme / Trace.s < prev   
Encoding:
Text File  |  1990-03-27  |  3.6 KB  |  102 lines  |  [TEXT/ttxt]
  1. ;; Extremely simple trace package, written in Scheme.  Has several flaws.
  2.  
  3. ;; Globals:
  4.  
  5. (define *trace-list* #f)         ;; List of names/values of procedures being traced.
  6.                                  ;;   Note that direct modification of this list does
  7.                                  ;;   NOT untrace procedures!
  8. (define *trace-on* #t)           ;; Is tracing enabled or not?
  9.  
  10. ;;;     TRACE-MANY     Trace all procedures whose names are listed, without showing
  11. ;                      arguments or results.
  12.  
  13. (define (trace-many . symbols)
  14.   (map (lambda (symbol) (e::trace-1 symbol #f #f)) symbols))
  15.  
  16. ;;;     E::TRACE-1     Trace the named procedure.  Booleans tell wether to display
  17. ;                      arguments when called, and result when returning.  Works by
  18. ;                      wrapping some extra stuff around the procecure that is bound
  19. ;                      to the given name, then assigning the result to that name.
  20. ;                      Saves the old procedure for possible untracing.
  21.  
  22. (define (e::trace-1 symbol show-args show-result)
  23.   (c::if (not (symbol? symbol))
  24.     (begin (newline) (display symbol)
  25.            (e::error "Not a symbol"))
  26.     #f)
  27.   (c::if (assv symbol *trace-list*)
  28.     (untrace symbol)
  29.     #f)
  30.   (let ((old (e::cons-with-continuation symbol)))
  31.     (c::if (not (procedure? old))
  32.       (begin (newline) (display symbol)
  33.              (e::error "Not a procedure"))
  34.       (begin
  35.         (set! *trace-list* (cons (cons symbol old) *trace-list*))
  36.         (e::cons-with-continuation
  37.           `(set! ,symbol
  38.             ,(lambda stuff
  39.                (let ((result #f))
  40.                  (c::if *trace-on*
  41.                    (begin (display "Enter ")
  42.                           (c::if show-args
  43.                             (display (cons symbol stuff))
  44.                             (display symbol))
  45.                           (newline))
  46.                    #f)
  47.                  (set! result (apply old stuff))
  48.                  (c::if *trace-on*
  49.                    (begin (display "Return ")
  50.                           (c::if show-result
  51.                             (begin (display result) (display " "))
  52.                             #f)
  53.                           (display "from ") 
  54.                           (c::if show-args
  55.                             (display (cons symbol stuff))
  56.                             (display symbol))
  57.                           (newline))
  58.                    #f)
  59.                  result))))
  60.          symbol))))
  61.  
  62. ;;;      TRACE     Renaming of e::trace-1.
  63.  
  64. (define trace e::trace-1)
  65.  
  66. ;;;      UNTRACE     Undo the change to the binding, done by calling trace-1,
  67. ;                    and remove the symbol from the list of traced procedures.
  68.  
  69. (define (untrace symbol)
  70.   (let ((pair (assv symbol *trace-list*)))
  71.     (c::if pair
  72.       (begin
  73.         (e::cons-with-continuation `(set! ,symbol ,(cdr pair)))
  74.         (set! *trace-list* (e::remove pair *trace-list*))
  75.         symbol)
  76.       #f)))
  77.  
  78. ;;;     UNTRACE-ALL     Untrace all symbols being traced.
  79.  
  80. (define (untrace-all) (map untrace (tracing?)))
  81.  
  82. ;;;     TRACE-ON      Enable tracing output.
  83.  
  84. (define (trace-on) (set! *trace-on* #t))
  85.  
  86. ;;;     TRACE-OFF      Disable tracing output.
  87.  
  88. (define (trace-off) (set! *trace-on* #f))
  89.  
  90. ;;;     TRACING?      Display procedures being traced.
  91.  
  92. (define (tracing?) (map car *trace-list*))
  93.  
  94. ;;;     E::REMOVE     Canonical code to remove first instance of thing from lyst.
  95.  
  96. (define (e::remove thing lyst)
  97.   (cond ((null? lyst) #f)
  98.         ((not (pair? lyst)) (e::error "Improper list - \"e::remove\""))
  99.         ((eqv? (car lyst) thing) (cdr lyst))
  100.         (else
  101.           (cons (car lyst) (e::remove thing (cdr lyst))))))
  102.